;;;
;;;# Introduction
;;; This is an Emacs extension to blogging on blogger.com. It allows one to use Emacs to login to blogger.com service,
;;; obtain a list of blogs, list entries in a blog, create/edit/delete entries.
;;;
;;; This extension is written using Luke Gorrie's pbook which is a literate programming tool for writing Emacs code. 
;;; You should be able to understand how this extension works by reading the document.
;;;
;;; The starting point to blogging using this in Emacs is to list the blog entries of a blog. You can do this by M-x 
;;; blog-api-blog-get-entries. That will ask for the bloger user account information and the name of the blog you want
;;; to list. The list of blog entries is then displayed in a buffer. A mode-specific help is available by C-h m.
;;;

;;;# Customizable variables
;;; The following variables can be customized to meet your needs.
;;;## Version of this extension.
(defvar blog-api-version "0.1")

;;;## Name of the blogger host.
;;; This is usually www.blogger.com or beta.blogger.com. The beta version of blogger requires us to redirect HTTP POST
;;; requests in a manner that is not compliant with HTTP 1.1 standard. blog-api-http-post method checks for the host name
;;; and performs some non-standard operations if the name starts with \textit{beta.}
(defcustom blog-api-host 
  "beta.blogger.com"
  "Hostname of the Atom API provider"
  :group 'blog-api)

;;;## Blogger user name 
;;; The user name for use in blogger publishing protocol.
(defvar blog-api-user-name nil)

;;;## Email (blogger user id)
;;; This is the blogger user id used to authenticate the user.
(defvar blog-api-email nil)

;;;## Blogger Password
;;; Password to authenticate the user.
(defvar blog-api-password nil)

;;;## Hash table of blogs
;;; User's blogs are maintained in this hash table. The entries are keyed by the blog name. The value stored is
;;; another hash table with blog attribute name and value pairs.
(defvar blog-api-blogs nil)

;;;## Gdata authorization token
;;; Upon successful authentication, Gdata returns an authorization token. This authorization token is required for performing
;;; blogger requests.
(defvar blog-api-auth-token nil)

;;;# Utility methods
;;; Here are some utility methods that we use.
;;;## Reading user's password.
;;; User's password is read once and stored in memory. Note that the password is not encrypted when it is stored in memory.
(defun blog-api-read-password ()
  (or blog-api-password
      (setf blog-api-password (read-passwd "Password: "))))
 
;;;## Erase the password if any
(defun blog-api-purge-password ()
  (interactive)
  (setf blog-api-password nil))

;;;## Reading user's email.
;;; User's email is read from the mini-buffer and stored in memory.
(defun blog-api-read-email ()
  (or blog-api-email
      (setf blog-api-email (read-string "Email: "))))

;;;## Reading user's name
;;; User's name is read from the mini-buffer and stored in memory.
(defun blog-api-read-user-name ()
  (or blog-api-user-name
      (setf blog-api-user-name (read-string "User Name: "))))

;;;## URL encoder
;;; Encodes a string using URL encoding format
(defun blog-api-url-encode (s)
  (let ((url-reserved (string-to-sequence "$&+,/:;=?@ \"<>#%{}|\\^~[]`" 'list)))
    (mapconcat (lambda (c) (format (if (memq c url-reserved) "%%%02X" "%c") c)) s "")))

;;;## Escaping XML delimiters
(defun blog-api-escape-xml (s)
  (mapconcat (lambda (c) 
               (cond ((equal c ?<) "&lt;")
                     ((equal c ?>) "&gt;")
                     (t (char-to-string c)))) s ""))

;;;# HTTP methods
;;; Blogger.com API is accessed by sending SOAP requests over HTTP. The server returns response in XML format. We need SSL support
;;; and the ability to handle HTTP protocol correctly. There is no ready made Emacs package to do this and we use curl to do it all
;;; for us. Since we don't do HTTP transactions very frequently, this approach works quite satisfactorily.

;;;## HTTP GET
;;; This method performs an HTTP GET. The headers argument contains additional headers that curl should send to the server. All
;;; the HTTP transactions use a single buffer. Care should be taken to avoid destroying a buffer when it might still be in use
;;; by some function.
;;;
;;; Sometimes, it is helpful to see protocol level trace of HTTP requests and response. curl.trc file contains this trace.
(defun blog-api-http-get (url headers)
  (message (concat "HTTP GET: " url))
  (with-current-buffer (get-buffer-create "*blog-api-buffer*")
    (erase-buffer)
    (apply #'call-process 
           `("curl.exe" 
             nil 
             ,(list (get-buffer-create "*blog-api-buffer*") "curl.trc")
             nil 
             "-L" 
             "-v"
             ,@(mapcar (lambda (h) h) headers)
             ,url))
    (buffer-substring-no-properties (point-min) (point-max))))

;;;## HTTP POST
;;; This method performs an HTTP POST. The workings of this method are similar to the previous method.
(defun blog-api-http-post (url headers data)
  (message (concat "HTTP POST: " url))
  (with-current-buffer (get-buffer-create "*blog-api-buffer*")
    (erase-buffer)
    (apply #'call-process 
           `("curl.exe" 
             nil 
             ,(list (get-buffer-create "*blog-api-buffer*") "curl.trc") 
             nil 
             "-L" 
             "-v"
             "--trace" "err.txt"
             ,@(mapcar (lambda (h) h) headers)
             "-d" ,data 
             ,url))
           (buffer-substring-no-properties (point-min) (point-max))))

;;;# Google authentication
;;;## Logging in
;;; To login to a google service, we need to send an HTTP POST request to https://www.google.com/accounts/ClientLogin with
;;; email and password. We also need to send name of the service as blogger and another data element telling it the name
;;; of the client software. Upon successful login, the authentication service returns an token. When the response does
;;; not include this token, an error is thrown.
(defun blog-api-gdata-login (email password)
  (let (response)
    (setf response (blog-api-http-post 
                    "https://www.google.com/accounts/ClientLogin" 
                    '()
                    (concat "Email=" (blog-api-url-encode email)
                            "&Passwd=" password 
                            "&service=blogger&source=true-editor-1\r\n")))
    (if (string-match "Auth=\\(.*\\)\n" response)
        (setq blog-api-auth-token (match-string 1 response))
      (error "Auth token not found in response"))))

;;;## Authentication header.
;;; This method returns an HTTP authorization header containing the Auth token. Most high-level methods
;;; can just call this method to obtain the header. If the email and password are required to be read, this
;;; method takes care of doing so.
(defun blog-api-google-auth-header ()
  (or blog-api-auth-token
      (blog-api-gdata-login (blog-api-read-email) (blog-api-read-password)))
  (concat "Authorization: GoogleLogin auth=" blog-api-auth-token))

;;;# Blogger API
;;;## Obtaining user's blogs
;;; This method retrieves a list of user's blogs and builds a hash table. A user's list of blogs
;;; can be retrieved by an HTTP GET on /feeds/default/blogs. The server returns an XML response
;;; which is parsed and a hash table representing the blog is populated.
(defun blog-api-blog-list ()
  (interactive)
  (with-current-buffer (get-buffer-create "*blog-api-buffer*")
    (unwind-protect
        (setf response (blog-api-http-get (concat blog-api-host "/feeds/default/blogs") 
                           (list "-H" "Content-Type: application/atom+xml"
                                 "-H" (blog-api-google-auth-header))))
      (let ((feed (xml-parse-region (point-min) (point-max))))
        (setf blog-api-blogs (blog-api-parse-feed feed)))))
  blog-api-blogs)

;;; The following method parses the XML document. A blog is represented by a 
(defun blog-api-parse-feed (feed)
  (let ((children (xml-node-children (car feed))) (blogs (make-hash-table))
	(blog-api-blogs (make-hash-table :test 'equal)))
    (while children
      (let ((child (car children)))
        (if (not (stringp child))
            (let ((el-name (xml-node-name child)) (attrs (xml-node-attributes child)))
              (when (eq 'entry el-name)
                (let ((id (caddar (xml-get-children child 'id)))
                      (title (caddar (xml-get-children child 'title)))
                      (rel (xml-get-children child 'link)))
                  (let ((blog (gethash title blog-api-blogs)))
                    (if (not blog)
                        (progn
                          (puthash title (make-hash-table :test 'equal) blog-api-blogs)
                          (setq blog (gethash title blog-api-blogs))))
                    (puthash 'id id blog)
                    (puthash 'title title blog)
                    (mapc (lambda (el) (puthash (xml-get-attribute el 'rel)
                                                (xml-get-attribute el 'href)
                                                blog)) rel)))))))
      (setq children (cdr children)))
    blog-api-blogs))

;;; A utility method to read the blog name. The mini-buffer is passed the list of blog names
;;; and user's selection is returned.
(defun blog-api-read-blog-name ()
  (let ((blog-names '()))
    (maphash (lambda (k v) (setf blog-names (cons (cons k 1) blog-names))) (blog-api-blog-list))
    blog-names
    (completing-read 
     "Select a blog: " 
     blog-names
     nil
     t
     nil
     'blog-list-history)))

;;;## Blog attribute accessors
;;;### Blog feed URL
(defun blog-api-blog-feed-url (blog)
  (gethash "http://schemas.google.com/g/2005#feed" blog))

;;;### Blog post URL
(defun blog-api-blog-post-url (blog)
  (let (url)
    (setf url (gethash "http://schemas.google.com/g/2005#post" blog))
    (if (equal (substring blog-api-host 0 5) "beta.")
        (if (string-match "\\(http://www\\)\\(.*\\)" url)
            (concat "http://beta" (match-string 2 url))
          url)
      url)))

;;;## Blog entry attribute accesscors
;;;### Blog entry URL
(defun blog-api-blog-entry-url (entry)
  (let ((links (xml-get-children entry 'link)) href)
    (setf href (xml-get-attribute 
                (find-if (lambda (l) 
                           (progn
                             (equal (xml-get-attribute l 'rel) "alternate"))) links)
                'href))
    href))

;;;### Blog entry edit URL
;;; Returns the edit URL for the blog entry.
;;; If the blog entry is hosted on the beta site, the edit URL is changed
;;; from "www." to "beta.". This ugly hack is necessary as blogger beta site
;;; sends an HTTP redirect 302 and expects the client o POST rather than a
;;; GET. Curl tries to do the right thing by doing a POST on HTTP status 302. 
(defun blog-api-blog-entry-edit-url (entry)
  (let ((links (xml-get-children entry 'link)) href)
    (setf href (xml-get-attribute 
                (find-if (lambda (l) 
                           (progn
                             (equal (xml-get-attribute l 'rel) "edit"))) links)
                'href))
    ; (hack for beta version)
    (if (equal (substring blog-api-host 0 5) "beta.")
        (if (string-match "\\(www\\)\\(.*\\)" href)
            (concat "beta" (match-string 2 href))
          href))))

;;;### Blog entry title
(defun blog-api-blog-entry-title (entry)
  (let ((node-list (xml-get-children entry 'title)))
    (caddar node-list)))

;;;### Blog entry content
(defun blog-api-blog-entry-content (entry)
  (let ((node-list (xml-get-children entry 'content)))
    (caddar node-list)))

;;;## Creating a new blog entry
(defun blog-api-blog-post ()
  (interactive)
  (let* ((blog-name (blog-api-read-blog-name))
         (blog (gethash blog-name (blog-api-blog-list)))
         (title (buffer-substring-no-properties (progn (goto-char (point-min)) (point)) (progn (end-of-line) (point))))
         (content (buffer-substring-no-properties (progn (goto-line 2) (point)) (point-max)))
	 (entry (concat
                 "<?xml version=\"1.0\"?>"
                 "<entry xmlns=\"http://www.w3.org/2005/Atom\" xmlns:app=\"http://purl.org/atom/app#\">"
                 "<author>"
                 "<name>" (blog-api-read-user-name) "</name>"
                 "<email>" (blog-api-read-email) "</email>"
                 "</author>"
                 "<app:control><app:draft>"(if (y-or-n-p "Publish?") "no" "yes") "</app:draft></app:control>"
                 "<title type=\"text\">" (blog-api-escape-xml title) "</title>"
                 "<content type=\"text\">" (blog-api-escape-xml content) "</content>"
                 "</entry>")))
     (setf response (blog-api-http-post (blog-api-blog-post-url blog)                            
                         (list "-H" "Content-Type: application/atom+xml"
                               "-H" (concat "Authorization: GoogleLogin auth=" blog-api-auth-token))
                         entry))
    (with-current-buffer (get-buffer-create "*blog-api-feed*")
      (erase-buffer)
      (insert response)
      (let ((xml (xml-parse-region (point-min) (point-max))) href)
        (setf href (blog-api-blog-entry-url (car xml)))
        (message (concat "Published at " href))))))

;;;## Updating a blog entry
(defun blog-api-blog-update (entry)
  (interactive)
  (let ((url (blog-api-blog-entry-edit-url entry)) request response
        (title (buffer-substring-no-properties (progn (goto-char (point-min)) (point)) (progn (end-of-line) (point))))
        (content (buffer-substring-no-properties (progn (goto-line 2) (point)) (point-max))))
    (setf request
          (concat
           "<?xml version=\"1.0\"?>"
           "<entry xmlns=\"http://www.w3.org/2005/Atom\" xmlns:app=\"http://purl.org/atom/app#\">"
           "<author>"
           "<name>" (blog-api-read-user-name) "</name>"
           "<email>" (blog-api-read-email) "</email>"
           "</author>"
           "<app:control><app:draft>"(if (y-or-n-p "Publish?") "no" "yes") "</app:draft></app:control>"
           "<title type=\"text\">" (blog-api-escape-xml title) "</title>"
           "<content type=\"text\">" (blog-api-escape-xml content) "</content>"
           "</entry>"))
    (message url)
    (message request)
    (setf response (blog-api-http-post 
                    url 
                    (list "-H" "Content-Type: application/atom+xml"
                          "-H" (concat "Authorization: GoogleLogin auth=" blog-api-auth-token)
                          "-H" "X-HTTP-Method-Override: PUT") 
                    request))
    (message response)))

;;;## Delete a blog entry
;;; TBD: The argument to this function should be just the entry edit URL
(defun blog-api-delete-entry (entry)
  (let (url)
    (string-match "..\\([^ ]*\\) +" entry)
    (setf url (match-string 1 entry))
    (blog-api-http-post url (list "-H" (concat "Authorization: GoogleLogin auth=" blog-api-auth-token)
                                  "-H" "X-HTTP-Method-Override: DELETE") "")))

;;;## Retrieving blog entries
(defun blog-api-blog-get-entries (blog-name)
  (interactive (list (blog-api-read-blog-name)))
  (let (feed entries title id)
    (blog-api-http-get (blog-api-blog-feed-url (gethash blog-name (blog-api-blog-list))) 
                       (list "-H" (blog-api-google-auth-header)))
    (with-current-buffer (get-buffer "*blog-api-buffer*")
      (setf feed (car (xml-parse-region (point-min) (point-max))))
      (setf entries (xml-get-children feed 'entry))
      (with-current-buffer (get-buffer-create (concat "*" blog-name "*"))
        (erase-buffer)
        (kill-all-local-variables)
        (insert (format "  Blog: %s\n" blog-name))
        (mapc (lambda (entry)
                (setf title (caddar (xml-get-children entry 'title)))
                (insert "  ")
                (let ((beg (point)))
                  (insert (blog-api-blog-entry-edit-url entry))
                  (insert " ")
                  (put-text-property beg (point) 'invisible t))
                (insert (format "%s" title))
                (insert-char ?\s (- 60 (length title)))
                (let ((updated (caddar  (xml-get-children entry 'updated))))
                  (string-match "\\(.+\\)[a-zA-Z]+\\([^.]+\\)" updated)
                  (insert (match-string 1 updated))
                  (insert " ")
                  (insert (match-string 2 updated))
                (insert "\n")))
              entries)
        (switch-to-buffer 
         (get-buffer-create (concat "*" blog-name "*")))
        (goto-line 2)
        (blog-dir-mode)))))

;;;# Blog mode
;;; We implement a blog directory mode. This is the primary mode for interacting with a blog. In this mode,
;;; we can view the entries, update and delete them. The interface is similar to dired mode.
;;;## Variables
;;;### Mode hook variable
(defvar blog-dir-mode-hook nil)

;;;### Key map for blog dir mode
;(makunbound 'blog-dir-mode-map)
(defvar blog-dir-mode-map
   (let ((map (make-sparse-keymap)))
     (suppress-keymap map)
     (define-key map "n" 'blog-dir-do-move-down)
     (define-key map "e" 'blog-dir-do-edit)
     (define-key map "U" 'blog-dir-do-unmark-all)
     (define-key map " " 'blog-dir-do-move-down)
     (define-key map "p" 'blog-dir-do-move-up)
     (define-key map "\177" 'blog-dir-unmark-backward)
     (define-key map "g" 'blog-dir-do-refresh)
     (define-key map "d" 'blog-dir-do-mark-delete)
     (define-key map "H" 'blog-dir-do-execute-unpublish)
     (define-key map "P" 'blog-dir-do-execute-publish)
     (define-key map "x" 'blog-dir-do-execute-delete)
     (define-key map "q" 'quit-window)
     map)
   "Keymap for `blog-dir-mode'.") 

;;;### Prefix key map
;(makunbound 'blog-api-prefix-map)
(defvar blog-api-prefix-map
   (let ((map (make-sparse-keymap)))
     (define-key map "l" 'blog-api-blog-get-entries)
     (define-key map "n" 'blog-dir-new-entry)
     (define-key map "s" 'blog-dir-save-entry)
     map))
     
(if (not (keymapp (lookup-key global-map "\C-xc")))
    (define-key global-map "\C-xc" blog-api-prefix-map))

;;;### Marker characters
;;; Special characters used in blog directory mode to tag entries and marking for delete
(defvar blog-dir-marker-char ?*)
(defvar blog-dir-del-marker ?D)

;;;### Font control
;(makunbound 'blog-dir-font-lock-keywords)
(defvar blog-dir-font-lock-keywords
  (list
   ;;
   ;; Marked files.
   (list (concat "^[" (char-to-string blog-dir-marker-char) "]")
         '(".+" (blog-dir-move-to-blog-entry) nil (0 blog-dir-marked-face)))
   ;;
   ;; Flagged files.
   (list (concat "^[" (char-to-string blog-dir-del-marker) "]")
         '(".+" (blog-dir-move-to-blog-entry) nil (0 blog-dir-flagged-face)))))

;;;## Blog directory functions
;;; These functions handle blog directory events

;;;### Utility methods
;;; This method applies the passed function to each of the blog entries in the blog directory
(defun blog-dir-map (func)
  "Apply func to each blog entry"
  (let (result)
    (save-excursion
      (goto-line 2)l
      (while (not (eobp))
        (setf result (cons (funcall func (buffer-substring-no-properties (line-beginning-position) (line-end-position))) result))
        (next-line)))
    (reverse result)))

;;; This method applies the passed function to each of the blog entries in the blog directory and returns the result of 
;;; each function application
(defun blog-dir-map-collect (pred)
  "Apply pred to each blog entry and collect the entries for which pred is true"
  (let (result entry)
    (save-excursion
      (goto-line 2)
      (while (not (eobp))
        (setf entry (buffer-substring-no-properties (line-beginning-position) (line-end-position)))
        (if (funcall pred entry)
            (setq result (cons entry result)))
        (next-line))
      (reverse result))))

;;; Positions the cursor to the blog entry on the current line
(defun blog-dir-move-to-blog-entry ()
  (beginning-of-line)
  (goto-char (+ (point) 2)))

;;;### Create a new blog entry
(defun blog-dir-new-entry ()
  (interactive)
  (switch-to-buffer (get-buffer-create "New Blog Entry"))
  (make-local-variable 'entry)
  (setf entry nil))

;;;### Blog directory navigation
;;; The following methods move up or down in the blog directory
(defun blog-dir-do-move-down (arg)
  (interactive "P")
  (next-line)
  (blog-dir-move-to-blog-entry))

(defun blog-dir-do-move-up (arg)
  (interactive "P")
  (previous-line)
  (blog-dir-move-to-blog-entry))

;;;### Refresh blog directory
(defun blog-dir-do-refresh (arg)
  (interactive "P")
  (save-excursion
    (message blog-name)))

;;;### Publish entries
(defun blog-dir-do-execute-publish (arg)
  (interactive "P")
  (let ((entries (blog-dir-map-collect (lambda (entry)
                                          (equal "*" (substring entry 0 1))))))
    (mapc (lambda (entry) (message (concat "Publish " entry))) entries)))

;;;### Unpublish entries
(defun blog-dir-do-execute-unpublish (arg)
  (interactive "P")
  (let ((entries (blog-dir-map-collect (lambda (entry)
                                          (equal "*" (substring entry 0 1))))))
    (mapc (lambda (entry) (message (concat "UnPublish " entry))) entries)))

;;;### Delete entries    
(defun blog-dir-do-execute-delete (arg)
  (interactive "P")
  (let ((entries (blog-dir-map-collect (lambda (entry)
                                          (equal "D" (substring entry 0 1))))))
    (mapc (lambda (entry) 
            (let (url)
              (string-match "..\\([^ ]*\\) +" entry)
              (setf url (match-string 1 entry))
              (blog-api-http-post url (list "-H" (concat "Authorization: GoogleLogin auth=" blog-api-auth-token)
                                            "-H" "X-HTTP-Method-Override: DELETE") "")))
          entries)
    (save-excursion
      (goto-line 1)
      (blog-api-blog-get-entries (buffer-substring-no-properties 9 (line-end-position))))))

;;;### Mark for delete
(defun blog-dir-do-mark-delete (arg)
  (interactive "P")
  (beginning-of-line)
  (delete-char 1) 
  (insert blog-dir-del-marker)
  (blog-dir-do-move-down 1))

;;;### Unmark and move up
(defun blog-dir-unmark-backward (arg)
  (interactive "P")
  (previous-line)
  (beginning-of-line)
  (subst-char-in-region (point) (1+ (point)) ?* ?\s)
  (blog-dir-move-to-blog-entry))
  
;;;### Edit entry
(defun blog-dir-do-edit ()
  (interactive)
  (let (line url title response content)
    (setf line (buffer-substring-no-properties (line-beginning-position) (line-end-position)))
    (string-match "..\\([^ ]*\\) +" line)
    (setf url (match-string 1 line))
    (switch-to-buffer (get-buffer-create url))
    (setf response (blog-api-http-get url '()))
    (make-local-variable 'entry)
    (setf entry (with-current-buffer (get-buffer-create "*blog-api-feed*")
                  (erase-buffer)
                  (insert response)
                  (car (xml-parse-region (point-min) (point-max)))))
    (setf title (blog-api-blog-entry-title entry))
    (setf content (blog-api-blog-entry-content entry))
    (while (string-match "<br />" content)
      (setf content (replace-match "\n" t t content nil)))
    (insert title "\n")
    (insert content)))

;;;### Save entry
(defun blog-dir-save-entry ()
  (interactive)
  (if entry
      (blog-api-blog-update entry)
    (blog-api-blog-post))
  (kill-buffer (current-buffer)))

;;;### Unmark all entries
(defun blog-dir-do-unmark-all (arg)
  (interactive "P")
  (save-excursion
    (goto-char (point-min))
    (while (not (eobp))
      (blog-dir-do-unmark-current 1)
      (forward-line))))

;;;### Unmark current blog entry and stay on the current line
(defun blog-dir-do-unmark-current (arg)
  (interactive "P")
  (beginning-of-line)
  (delete-char 1) (insert ?\s)
  (blog-dir-move-to-blog-entry))

;;;## Blog directory function
(defun blog-dir-mode (&optional dirname switches)
  "A major-mode to edit blogs
\\{blog-dir-mode-map}
"
  (interactive)
  (kill-all-local-variables)
  (setq major-mode 'blog-dir-mode)
  (setq mode-name "BlogList")
  (use-local-map blog-dir-mode-map)
  (set (make-local-variable 'font-lock-defaults)
       '(blog-dir-font-lock-keywords t nil nil beginning-of-line))
  (run-hooks 'blog-dir-mode-hook))

(provide 'atom-api)



